perm filename INMRK.F4[NEW,LCS] blob
sn#592315 filedate 1981-06-07 generic text, type T, neo UTF8
00100 C************ READX, NEWMRK, ISNUM, DOIT, MORMRK,
00200
00300 SUBROUTINE READX
00400 COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /ALF/INP(72)/SCM/V(78)
00500 EQUIVALENCE (V(2),V2)
00600 C****320 REREAD 2430,J,R2,RJQ
00700 C ↑↑↑ 1/78
00800 DO 2 K=2,72
00900 IF(INP(K).NE.'<')GO TO 2
01000 DO 3 J=K,72
01100 3 INP(J)=' '
01200 GO TO 4
01300 2 CONTINUE
01400 C CATCH '<' -- WHICH = COMMENT FOR REST OF LINE
01500 4 CALL RREAD(INP,V)
01600 JA=V(1)
01700 R2=V2
01800 DO 1 K=1,20
01900 1 RJQ(K)=V(K+2)
02000 END
02100
02200 FUNCTION ISNUM(M)
02300 C ISNUM=0 IF M=A NUMBER. ASSUMES A DOT MEANS DECIMAL POINT
02400 ISNUM=-1
02500 IF(M.EQ.'.')ISNUM=0
02600 IF(M.GE.'0'.AND.M.LE.'9')ISNUM=0
02700 END
02800
02900 SUBROUTINE NEWMRK(VX)
03000 DIMENSION VX(1)
03100 COMMON /DPY/ST(3690),N(1),N2,N3,JN(72),KN(172),RX(50),JJ,NN,MM
03200 1 /SC/A,B,C,D,E,NNN /ALF/INP(1) /MX/MX,MZ
03300 J=1
03400 34 J=J+1
03500 35 IF(ISNUM(INP(J)).NE.0)GO TO 30
03600 DO 31 MM=J+1,72
03700 M=INP(MM)
03800 IF(M.EQ.'/')GO TO 30
03900 IF(M.EQ.';')GO TO 30
04000 IF(M.EQ.'*')GO TO 30
04100 IF(M.NE.' ')GO TO 31
04200 C NOW FOUND SPACE AFTER NUMB.
04300 DO 32 J=MM+1,72
04400 M=INP(J)
04500 IF(M.EQ.' ')GO TO 32
04600 IF(ISNUM(M).NE.0)GO TO 30
04700 C FOUND SOMETHING, BUT NOT NUMB.
04800 INP(MM)=','
04900 C FOUND NUMB, SO PUT IN COMMA
05000
05100 IF(J.LT.72)GO TO 35
05200 GO TO 33
05300 32 CONTINUE
05400 GO TO 33
05500 31 CONTINUE
05600 GO TO 33
05700 30 IF(J.LT.72)GO TO 34
05800 33 MX=0
05900 C MX IS FLAG FOR LINE TOO LONG IN NEW FORMAT
06000 J=0
06100 MM=0
06200 10 JJ=0
06300 NN=0
06400 N2=0
06500 1 J=J+1
06600 IF(J.GT.72)GO TO 20
06700 C JUMP IF DONE
06800 M=INP(J)
06900 CURRENT CHARACTER
07000 IF(M.EQ.'-')GO TO 21
07100 C '-' NEEDED FOR "C-" (DECRESC. SIGN)
07200 IF(M.LT.'A'.OR.M.GT.'Z')GO TO 2
07300 C JUMP IF A LETTER IS NOT FOUND
07400 21 JJ=JJ+1
07500 N(JJ)=M
07600 GO TO 1
07700 2 IF(M.EQ.' ')GO TO 1
07800 5 NN=NN+1
07900 JN(NN)=M
08000 C SAVE THE NUMBER CHARS.
08100 6 J=J+1
08200 M=INP(J)
08300 CC IF(M.GE.'0'.AND.M.LE.'9')GO TO 5
08400 CC IF(M.EQ.'.')GO TO 5
08500 IF(ISNUM(M).EQ.0)GO TO 5
08600 CXX IF(M.NE.':')GO TO 22
08700 IF(M.NE.'!')GO TO 22
08800 M='-'
08900 C NEG. N2 WILL =TOTAL OF ITEMS STARTING WITH N1( /S 12!3/=/S 12:14/)
09000 NN=NN+1
09100 JN(NN)=' '
09200 GO TO 5
09300 22 IF(M.EQ.' ')GO TO 6
09400 IF(M.NE.':')GO TO 7
09500 C NOW A SEQUENCE OF ITEMS
09600 M=' '
09700 GO TO 5
09800 7 IF(M.NE.',')GO TO 8
09900 C NOW A SINGLE ITEM
10000 CALL DOIT
10100 NN=0
10200 C ITEM OR ITEMS NOW FINISHED
10300 GO TO 6
10400 8 IF(M.NE.'/')GO TO 11
10500 CALL DOIT
10600 GO TO 10
10700 11 IF(M.NE.';'.AND.M.NE.'*')GO TO 6
10800 C JUMP IF UNKNOWN CHAR.
10900 CALL DOIT
11000 KN(MM)=M
11100 IF(MM.LE.71)GO TO 20
11200 C SKIP IF REVISED LINE NOT TOO LONG
11300 MZ=MM
11400 DO 201 MM=71,1,-1
11500 201 IF(KN(MM).EQ.'/')GO TO 202
11600 202 MX=MM+1
11700 C POINTS TO START OF REMAINDER OF TOO-LONG LINE
11800 INP(72)=0
11900 20 CALL MORMRK(1,MM,VX)
12000 END
12100
12200 SUBROUTINE DOIT
12300 COMMON /DPY/ST(3690),N(1),N2,N3,JN(72),KN(172),RX(50),JJ,NN,MM
12400 IF(N(1).NE.'C'.AND.N(1).NE.'O')GO TO 3
12500 CATCHES /C 5-7/C- 11.2-13.5/O 1-21/ ETC.
12600 IF(N2.EQ.'R')GO TO 3
12700 C JUMP IF "CR" FOR WORD "CRESC."
12800 DO 4 K=1,NN
12900 MM=MM+1
13000 JX=JN(K)
13100 KN(MM)=JX
13200 4 IF(JX.EQ.' ')GO TO 5
13300 C FIRST NUMBER COMPLETED
13400 5 DO 6 JX=1,JJ
13500 MM=MM+1
13600 6 KN(MM)=N(JX)
13700 CODE LETTER INSERTED
13800 MM=MM+1
13900 KN(MM)=' '
14000 DO 7 JX=K+1,NN
14100 C NOW PUT IN LAST NUMBER
14200 MM=MM+1
14300 7 KN(MM)=JN(JX)
14400 GO TO 8
14500 3 DO 1 K=1,NN
14600 MM=MM+1
14700 1 KN(MM)=JN(K)
14800 MM=MM+1
14900 KN(MM)=' '
15000 DO 2 K=1,JJ
15100 MM=MM+1
15200 2 KN(MM)=N(K)
15300 C NOW PUT IN THE CODE WORD
15400 8 MM=MM+1
15500 KN(MM)='/'
15600 CLOSE OFF THE ITEM
15700 END
15800
15900 CC SUBROUTINE MORMRK(VX)
16000 SUBROUTINE MORMRK(MA,MB,VX)
16100 DIMENSION VX(1)
16200 COMMON /DPY/ST(3690),N(1),N2,N3,JN(72),KN(172),RX(50),JO,NN,MM
16300 1 /SC/A,B,C,D,E,NNN /ALF/INP(1) /MX/MX,MZ
16400 CC K=0
16500 MM=0
16600 C GET THE REST OF A TOO-LONG LINE
16700 DO 1 K=MA,MB
16800 CC DO 1 J=MX,MZ
16900 MM=MM+1
17000 CC K=K+1
17100 1 INP(MM)=KN(K)
17200 CC1 INP(K)=KN(J)
17300 CC MM=K
17400 DO 13 K=MM+1,72
17500 13 INP(K)=' '
17600 IF(INP(MM).EQ.'*')INP(72)='*'
17700 C LINE ENDS WITH * OR ;
17800 C NOW GO FIX UP THE VX ARRAY.
17900 3 CALL RREAD(INP,VX)
18000 DO 23 K=1,50
18100 X=VX(K)
18200 IF(X.GT.0)Z=X
18300 C SAVE THE LAST POSITIVE NUM.
18400 IF(X.LT.0)VX(K)=-X+Z-1.
18500 C /S 17:5/=/S 17-21/ I.E. 5 NOTES STACCATO, STARTING WITH 17
18600 23 CONTINUE
18700 999 NNN=VX(1)
18800 CC MX=0
18900 END